Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/codeco1a/frmaddin.frm

Visual Basic Form | 1999-06-26 | 30.1 KB | 876 lines

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmAddIn
   BorderStyle     =   3  'Fester Dialog
   Caption         =   "Code Completer"
   ClientHeight    =   3600
   ClientLeft      =   2175
   ClientTop       =   2220
   ClientWidth     =   6030
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3600
   ScaleWidth      =   6030
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  'Bildschirmmitte
   Begin VB.CheckBox chkBottom
      Caption         =   "Bottom"
      Height          =   375
      Left            =   3960
      TabIndex        =   8
      Top             =   420
      Width           =   795
   End
   Begin VB.CheckBox chkTop
      Caption         =   "Top"
      Height          =   375
      Left            =   3960
      TabIndex        =   7
      Top             =   0
      Width           =   795
   End
   Begin VB.TextBox txtModErrHandling
      Height          =   555
      Left            =   0
      MultiLine       =   -1  'True
      TabIndex        =   6
      Text            =   "frmAddIn.frx":0000
      Top             =   3000
      Width           =   6015
   End
   Begin VB.TextBox txtBottom
      Height          =   1035
      Left            =   3960
      MultiLine       =   -1  'True
      TabIndex        =   5
      Text            =   "frmAddIn.frx":04A4
      Top             =   1920
      Width           =   2055
   End
   Begin VB.TextBox txtTop
      Height          =   1035
      Left            =   3960
      MultiLine       =   -1  'True
      TabIndex        =   4
      Text            =   "frmAddIn.frx":04AA
      Top             =   840
      Width           =   2055
   End
   Begin VB.TextBox txtCode
      Height          =   2955
      Left            =   1800
      MultiLine       =   -1  'True
      TabIndex        =   3
      Text            =   "frmAddIn.frx":04B0
      Top             =   0
      Width           =   2115
   End
   Begin MSComctlLib.TreeView tvComponents
      Height          =   2955
      Left            =   0
      TabIndex        =   2
      Top             =   0
      Width           =   1755
      _ExtentX        =   3096
      _ExtentY        =   5212
      _Version        =   393217
      Indentation     =   584
      Style           =   7
      Checkboxes      =   -1  'True
      Appearance      =   1
   End
   Begin VB.CommandButton CancelButton
      Caption         =   "&Abbrechen"
      Height          =   375
      Left            =   4800
      TabIndex        =   1
      Top             =   420
      Width           =   1215
   End
   Begin VB.CommandButton OKButton
      Caption         =   "&OK"
      Height          =   375
      Left            =   4800
      TabIndex        =   0
      Top             =   0
      Width           =   1215
   End
   Begin VB.Menu mnuB
      Caption         =   "Actions"
      Begin VB.Menu mnuBInsertErrC
         Caption         =   "Insert Err MsgBox"
         Index           =   0
      End
      Begin VB.Menu mnuBInsertErrC
         Caption         =   "Insert Err.Raise"
         Index           =   1
      End
      Begin VB.Menu mnuBInsertErrC
         Caption         =   "Insert Err.Raise MTS"
         Index           =   2
      End
      Begin VB.Menu mnuInsertErrConst
         Caption         =   "Insert ErrConst for Member"
      End
   End
   Begin VB.Menu mnuO
      Caption         =   "Options"
      Begin VB.Menu mnuOptResumeNextExit
         Caption         =   "MsgResumeNextExit"
      End
      Begin VB.Menu mnuOptSetAbort
         Caption         =   "Set Abort"
         Checked         =   -1  'True
      End
      Begin VB.Menu mnuOptSetComplete
         Caption         =   "Set Complete"
         Checked         =   -1  'True
      End
      Begin VB.Menu mnuDelOthers
         Caption         =   "Delete other ErrHandlers"
      End
      Begin VB.Menu mnuOptStatus
         Caption         =   "gStatus"
         Checked         =   -1  'True
      End
   End
   Begin VB.Menu mnuInfo
      Caption         =   "Info"
   End
Attribute VB_Name = "frmAddIn"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' Code for frmAddin (form)
' By J.M.Goebel
' This Code is Freeware if you use this code to develop new Application
' it may only be distributed as Freeware!
' just paste this code into frmAddin after you created a new AddIn-Project
' when you start the program with full compile you will see which controls
' are missing.
' Controls starting with mnu... are Menus
' Controls starting with txt... are TextBoxes
' Controls starting with chk... are checkboxes
' all textboxes must be multiline!
' you have to paste the code of modErrHandling into txtModErrHanlding
' you can also edit the file of frmAddin and replace the part before the code
' with this (remove the ' before each line before) Ther will be an error because
' of the missing frx-file but you only have to paste the content of modErrHandling
' into the text of txtModErrHandling :
'Version 5#
'Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
'Begin VB.Form frmAddIn
'   BorderStyle = 3        'Fester Dialog
'   Caption = "Code Completer"
'   ClientHeight = 3600
'   ClientLeft = 2175
'   ClientTop = 2220
'   ClientWidth = 6030
'   LinkTopic = "Form1"
'   MaxButton = 0           'False
'   MinButton = 0           'False
'   ScaleHeight = 3600
'   ScaleWidth = 6030
'   ShowInTaskbar = 0       'False
'   StartUpPosition = 2    'Bildschirmmitte
'   Begin VB.CheckBox chkBottom
'      Caption = "Bottom"
'      Height = 375
'      Left = 3960
'      TabIndex = 8
'      Top = 420
'      Width = 795
'   End
'   Begin VB.CheckBox chkTop
'      Caption = "Top"
'      Height = 375
'      Left = 3960
'      TabIndex = 7
'      Top = 0
'      Width = 795
'   End
'   Begin VB.TextBox txtModErrHandling
'      Height = 555
'      Left = 0
'      MultiLine = -1          'True
'      TabIndex = 6
'      Text            =   "frmAddIn.frx":0000
'      Top = 3000
'      Width = 6015
'   End
'   Begin VB.TextBox txtBottom
'      Height = 1035
'      Left = 3960
'      MultiLine = -1          'True
'      TabIndex = 5
'      Text            =   "frmAddIn.frx":0293
'      Top = 1920
'      Width = 2055
'   End
'   Begin VB.TextBox txtTop
'      Height = 1035
'      Left = 3960
'      MultiLine = -1          'True
'      TabIndex = 4
'      Text            =   "frmAddIn.frx":0299
'      Top = 840
'      Width = 2055
'   End
'   Begin VB.TextBox txtCode
'      Height = 2955
'      Left = 1800
'      MultiLine = -1          'True
'      TabIndex = 3
'      Text            =   "frmAddIn.frx":029F
'      Top = 0
'      Width = 2115
'   End
'   Begin MSComctlLib.TreeView tvComponents
'      Height = 2955
'      Left = 0
'      TabIndex = 2
'      Top = 0
'      Width = 1755
'      _ExtentX        =   3096
'      _ExtentY        =   5212
'      _Version        =   393217
'      Indentation = 584
'      Style = 7
'      Checkboxes = -1         'True
'      Appearance = 1
'   End
'   Begin VB.CommandButton CancelButton
'      Caption = "&Abbrechen"
'      Height = 375
'      Left = 4800
'      TabIndex = 1
'      Top = 420
'      Width = 1215
'   End
'   Begin VB.CommandButton OKButton
'      Caption = "&OK"
'      Height = 375
'      Left = 4800
'      TabIndex = 0
'      Top = 0
'      Width = 1215
'   End
'   Begin VB.Menu mnuB
'      Caption = "Bearbeiten"
'      Begin VB.Menu mnuBInsertErrC
'         Caption = "Insert Err MsgBox"
'         Index = 0
'      End
'      Begin VB.Menu mnuBInsertErrC
'         Caption = "Insert Err.Raise"
'         Index = 1
'      End
'      Begin VB.Menu mnuBInsertErrC
'         Caption = "Insert Err.Raise MTS"
'         Index = 2
'      End
'      Begin VB.Menu mnuInsertErrConst
'         Caption = "Insert ErrConst for Member"
'      End
'   End
'   Begin VB.Menu mnuO
'      Caption = "Optionen"
'      Begin VB.Menu mnuOptResumeNextExit
'         Caption = "MsgResumeNextExit"
'      End
'      Begin VB.Menu mnuOptSetAbort
'         Caption = "Set Abort"
'      End
'      Begin VB.Menu mnuOptSetComplete
'         Caption = "Set Complete"
'      End
'      Begin VB.Menu mnuOptStatus
'         Caption = "gStatus"
'      End
'   End
'   Begin VB.Menu mnuInfo
'      Caption = "Info"
'   End
'Attribute VB_Name = "frmAddIn"
'Attribute VB_GlobalNameSpace = False
'Attribute VB_Creatable = False
'Attribute VB_PredeclaredId = True
'Attribute VB_Exposed = False
Public VBInstance As VBIDE.VBE
Public Connect As Connect
Option Explicit
Private Enum ErrTypes
  errTMsgBox
  errTRaise
  errTRaiseWithSetAbort
End Enum
Private Type MemberProps
  Top As Long
  Body As Long
  Lines As Long
  TopGet As Long
  BodyGet As Long
  LinesGet As Long
  TopSet As Long
  BodySet As Long
  LinesSet As Long
  Type As String
  Code As CodeModule
  ParentName As String
End Type
Private mRightClickedMember As Member
Public Sub LoadComponents()
Dim Projekt As VBProject
Dim Comp As VBComponent
Dim newNode As Node
Dim ChildNode As Node
Dim Member As Member
On Error GoTo LoadErr
Set Projekt = VBInstance.ActiveVBProject
gStatus = "LoadComponents"
Me.Caption = Connect.VBInstance.ActiveVBProject.Name
gStatus = "Getting Components"
tvComponents.Nodes.Clear
Set newNode = tvComponents.Nodes.Add(, tvwFirst, "Root", "-")
For Each Comp In Projekt.VBComponents
  On Error Resume Next
  If Comp.CodeModule Is Nothing Then Debug.Print "Null"
  If Err.Number = 0 Then
    On Error GoTo LoadErr
    If Comp.CodeModule Is Nothing = False Then
      Set newNode = tvComponents.Nodes.Add(newNode.Index, tvwNext, _
        , Comp.Name)

      For Each Member In Comp.CodeModule.Members
        If Member.Type = vbext_mt_Method _
          Or Member.Type = vbext_mt_Property Then
          Set ChildNode = tvComponents.Nodes.Add _
            (newNode.Index, tvwChild, , Member.Name)
          Set ChildNode.Tag = Member
        End If
      Next Member
    End If
  End If
Next Comp
Exit Sub
LoadErr:
MsgBox Err.Description
End Sub
Private Sub CancelButton_Click()
    Connect.Hide
End Sub
Private Sub Check1_Click()
End Sub
Private Sub lstProcedures_Click()
End Sub
Private Sub mnuBInsertErrC_Click(Index As Integer)
Dim Member As Member
Dim object As Object
Dim Code As CodeModule
Dim Start As Long
Dim BodyStart As Long
Dim Lines As Long
Dim Node As Node
Dim DeleteOld As Boolean
On Error GoTo ErrHandler
For Each Node In tvComponents.Nodes
  If Node.Checked Then
    GoSub StartInsert
  End If
Next Node
Exit Sub
StartInsert:
If IsNull(Node.Tag) = False Then
  If IsObject(Node.Tag) Then
    Set object = Node.Tag
    If TypeOf object Is Member Then
      Set Member = Node.Tag

      InsertErrorCode Member, Index
    End If
  End If
End If
Return
ErrHandler:
Error_Checker:
   Dim pstrError As String
   With Err
     pstrError = .Source & " caused Error #" & _
    .Number & " during operation " & .Description & vbCrLf & "Click Help to See Topic " & .HelpContext & " in the file " & .HelpFile & "."
     MsgBox pstrError, vbMsgBoxHelpButton, _
     "Error: " & .Description, .HelpFile, .HelpContext
     .Clear
   End With
End Sub
Private Sub mnuDelOthers_Click()
 mnuDelOthers.Checked = mnuDelOthers.Checked Xor True
End Sub
Private Sub mnuInfo_Click()
Dim msg As String
msg = msg + "Code Completer by J.M.Goebel" + vbCrLf
msg = msg + "E-Mail: [e-mail] + [e-mail] + [e-mail]" + vbCrLf
msg = msg + "Version " & App.Major & "." & App.Minor & "." & App.Revision & vbCrLf
msg = msg + "This is a Beta Version! No warranties whatsoever"
MsgBox msg
End Sub
Private Sub mnuInsertErrConst_Click()
  If mRightClickedMember Is Nothing = False Then
    Call InsertNextErrorConstant(mRightClickedMember)
    Set mRightClickedMember = Nothing
  End If
End Sub
Private Sub mnuOptgStatus_Click()
End Sub
Private Sub mnuOptResumeNextExit_Click()
  mnuOptResumeNextExit.Checked = mnuOptResumeNextExit.Checked Xor True
End Sub
Private Sub mnuOptSetAbort_Click()
    mnuOptSetAbort.Checked = mnuOptSetAbort.Checked Xor True
End Sub
Private Sub mnuOptSetComplete_Click()
  mnuOptSetComplete.Checked = mnuOptSetComplete.Checked Xor True
End Sub
Private Sub mnuOptStatus_Click()
    mnuOptStatus.Checked = mnuOptStatus.Checked Xor True
End Sub
Private Sub OKButton_Click()
    MsgBox "AddIn operation on: " & VBInstance.FullName
End Sub
Private Sub ClearTExt()
  txtCode.Text = ""
  txtTop = ""
  txtBottom = ""
End Sub
Private Sub tvComponents_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim Node As Node
Dim object As Object
Dim Member As Member
If Button <> vbRightButton Then Exit Sub
Set Node = tvComponents.HitTest(x, y)
If Node Is Nothing Then Exit Sub
If IsNull(Node.Tag) = False Then
  If IsObject(Node.Tag) Then
    Set object = Node.Tag
    If TypeOf object Is Member Then
      Set Member = Node.Tag
      Set mRightClickedMember = Member
      PopupMenu mnuB
    End If
  End If
End If
End Sub
Private Sub tvComponents_NodeClick(ByVal Node As MSComctlLib.Node)
Dim Member As Member
Dim object As Object
Dim Code As CodeModule
Dim Start As Long
Dim BodyStart As Long
Dim Lines As Long
Dim n As Node
On Error Resume Next
ClearTExt
If IsNull(Node.Tag) = False Then
  If IsObject(Node.Tag) Then
    Set object = Node.Tag
    If TypeOf object Is Member Then
      Set Member = Node.Tag
      Set Code = Member.Collection.Parent
      If Member.Type = vbext_mt_Method Then
        'start = member.CodeLocation
        Start = Code.ProcStartLine(Member.Name, vbext_pk_Proc)
        Lines = Code.ProcCountLines(Member.Name, vbext_pk_Proc)
        BodyStart = Code.ProcBodyLine(Member.Name, vbext_pk_Proc)
      ElseIf Member.Type = vbext_mt_Property Then
        Start = Code.ProcStartLine(Member.Name, vbext_pk_Let)
        If Start = 0 Then Exit Sub
        Lines = Code.ProcCountLines(Member.Name, vbext_pk_Let)
        BodyStart = Code.ProcBodyLine(Member.Name, vbext_pk_Let)
      End If
      txtCode.Text = Code.Lines(Start, Lines)
      txtTop = Code.Lines(BodyStart, 1)
      txtBottom = Code.Lines(Start + Lines - 2, 2)
    End If
  End If
  If Not Node.Child Is Nothing Then
    Set n = Node.Child
    While Not n Is Nothing
      n.Checked = Node.Checked
      Set n = n.Next
    Wend
  End If
End If
End Sub
Private Function FindErrorModule() As VBComponent
Dim Pr As VBProject
Dim Comp As VBComponent
Set Pr = VBInstance.ActiveVBProject
On Error Resume Next
Set Comp = Pr.VBComponents("modErrorHandling")
On Error GoTo 0
If Comp Is Nothing Then
  Set Comp = Pr.VBComponents.Add(vbext_ct_StdModule)
  Comp.Name = "modErrorHandling"
  Comp.CodeModule.InsertLines 1, txtModErrHandling
End If
Set FindErrorModule = Comp
End Function
Private Function InsertNextErrorConstant(Mmb As Member) As String
Dim Pr As VBProject
Dim ErrComp As VBComponent
Dim ErrConstName As String
Dim AllComponentErrorOffset As Long
Dim ThisComponentErrorOffset As Long
Dim MemberErrorNumber As Long
Dim MemberErrorConstName As String ' Constante f
r ErrorNummer des Members
Dim CompErrConstName As String 'Constante f
r Error Offset der Komponente
Const AllErrConstName = "ComponentErrorOffset"
Dim mbrErrConstOfMember As Member 'Die Constante die den Error f
r das Member enth
Dim mbrErrConstOffsetComponent As Member
Dim mbrErrConstOffsetAll As Member
Dim LineInsert As Long
Set Pr = Mmb.VBE.ActiveVBProject
Set ErrComp = FindErrorModule
MemberErrorConstName = "Err" & EraseSpaces(Mmb.Collection.Parent.Parent.Name) & "_" & EraseSpaces(Mmb.Name)
On Error Resume Next
Set mbrErrConstOfMember = ErrComp.CodeModule.Members(MemberErrorConstName)
If Err.Number <> 0 Then
  Err.Clear
  CompErrConstName = "ErrOffs" & Mmb.Collection.Parent.Parent.Name
  Set mbrErrConstOffsetComponent = ErrComp.CodeModule.Members(CompErrConstName)
  If Err.Number <> 0 Then
    Err.Clear
    Set mbrErrConstOffsetAll = ErrComp.CodeModule.Members(AllErrConstName)
    If Err.Number <> 0 Then
      Err.Clear
      On Error GoTo 0
      Err.Raise vbObjectError, "InsertNextErrorConstant", "ComponentErrorOffset not found!"
    End If
    AllComponentErrorOffset = Val(GetValueOfConstant(mbrErrConstOffsetAll))
    LineInsert = mbrErrConstOffsetAll.CodeLocation
    ThisComponentErrorOffset = AllComponentErrorOffset + 100
    ' Neuen AllComponents ErrorOffset reinschreiben
    Call ErrComp.CodeModule.ReplaceLine(LineInsert, "Public Const " & AllErrConstName _
      & " = " & ThisComponentErrorOffset)
    ' Neuen ThisComponentErrorOffset erzeugen
    LineInsert = LineInsert + 1
    ErrComp.CodeModule.InsertLines LineInsert, "' Fehler Konstanten f
r Modul " & Mmb.Collection.Parent.Parent.Name
    LineInsert = LineInsert + 1
    ErrComp.CodeModule.InsertLines LineInsert, "Public Const " _
      & CompErrConstName & " = " & ThisComponentErrorOffset
  Else
    ThisComponentErrorOffset = GetValueOfConstant(mbrErrConstOffsetComponent)
    ThisComponentErrorOffset = ThisComponentErrorOffset + 1
    LineInsert = mbrErrConstOffsetComponent.CodeLocation
    ' ThisComponentError Offset updaten
    Call ErrComp.CodeModule.ReplaceLine(LineInsert, "Public Const " & CompErrConstName _
      & " = " & ThisComponentErrorOffset)
  End If
  MemberErrorNumber = ThisComponentErrorOffset
  ' neue MemberErrorConstante reinschreiben
  LineInsert = LineInsert + 1
  ErrComp.CodeModule.InsertLines LineInsert, "Public Const " _
      & MemberErrorConstName & " = " & ThisComponentErrorOffset & " + vbObjectError"
End If
InsertNextErrorConstant = MemberErrorConstName
End Function
Private Function GetValueOfConstant(mbrConst As Member) As Variant
Dim CodeLocation As Long
Dim strCode As String
Dim Value As String
CodeLocation = mbrConst.CodeLocation
strCode = mbrConst.Collection.Parent.Lines(CodeLocation, 1)
Value = Mid(strCode, InStr(1, strCode, " = ") + 3, Len(strCode))
GetValueOfConstant = Value
End Function
Private Function AnalyseMember(Member As Member) As MemberProps
Dim object As Object
Dim Code As CodeModule
Dim Start As Long
Dim BodyStart As Long
Dim Lines As Long
On Error Resume Next
    If Member Is Nothing = False Then
      Set Code = Member.Collection.Parent
      If Member.Type = vbext_mt_Method Then
        'start = member.CodeLocation
        Start = Code.ProcStartLine(Member.Name, vbext_pk_Proc)
        Lines = Code.ProcCountLines(Member.Name, vbext_pk_Proc)
        BodyStart = Code.ProcBodyLine(Member.Name, vbext_pk_Proc)
        If InStr(1, Code.Lines(BodyStart, 1), "Function ") > 0 Then
          AnalyseMember.Type = "Function"
        ElseIf InStr(1, Code.Lines(BodyStart, 1), "Sub ") > 0 Then
          AnalyseMember.Type = "Sub"
        End If
      ElseIf Member.Type = vbext_mt_Property Then
getLet:
        Start = Code.ProcStartLine(Member.Name, vbext_pk_Let)
        If Err.Number <> 0 Then GoTo getGet
        Lines = Code.ProcCountLines(Member.Name, vbext_pk_Let)
        BodyStart = Code.ProcBodyLine(Member.Name, vbext_pk_Let)
getGet:
        AnalyseMember.TopGet = Code.ProcStartLine(Member.Name, vbext_pk_Get)
        If Err.Number <> 0 Then GoTo getSet
        AnalyseMember.LinesGet = Code.ProcCountLines(Member.Name, vbext_pk_Get)
        AnalyseMember.BodyGet = Code.ProcBodyLine(Member.Name, vbext_pk_Get)
getSet:
        AnalyseMember.TopSet = Code.ProcStartLine(Member.Name, vbext_pk_Set)
        If Err.Number <> 0 Then GoTo endGet
        AnalyseMember.LinesSet = Code.ProcCountLines(Member.Name, vbext_pk_Set)
        AnalyseMember.BodySet = Code.ProcBodyLine(Member.Name, vbext_pk_Set)
endGet:

        AnalyseMember.Type = "Property"
      End If
      If Lines > 0 Then
        AnalyseMember.Body = BodyStart
        AnalyseMember.Lines = Lines
        AnalyseMember.Top = Start
        Set AnalyseMember.Code = Code
        AnalyseMember.ParentName = Member.Collection.Parent.Parent.Name
      End If

    End If
End Function
Private Sub InsertErrorCode(Member As Member, ByVal ErrType As ErrTypes)
Dim Props As MemberProps
Dim Name As String
Dim i As Long
Dim iCountDim As Long
Dim iStart As Long
Dim CodeFound As Boolean
Dim f1%, f2%
Dim Einrueck&
Dim OldErrHandlerFound!, DeleteOld!
Dim Loops As Integer
Dim strInsert As String
Dim ErrConstName As String
Dim ProcKind As vbext_ProcKind
Dim OtherErrHandler As String
Dim DeleteOther As Boolean
Dim strTmp As String
Props = AnalyseMember(Member)
' Erste CodeZeile finden
If Props.Type = "Property" Then
    Loops = 2
End If
' Bei Properties muss man unterscheiden zwischen Get, Set und Let
  OtherErrHandler = "xyz"
  ProcKind = vbext_pk_Proc
  If Props.Type = "Property" Then
    ProcKind = vbext_pk_Let
    While Props.Lines = 0
      Props = AnalyseMember(Member)
      If Loops = 2 Then
        ProcKind = vbext_pk_Get
        Props.Lines = Props.LinesGet
        Props.Body = Props.BodyGet
        Props.Top = Props.TopGet
        Loops = 1
      ElseIf Loops = 1 Then
        ProcKind = vbext_pk_Set
        Props.Lines = Props.LinesSet
        Props.Body = Props.BodySet
        Props.Top = Props.TopSet
        Loops = 0
      Else
        Exit Do
      End If
    Wend
  End If
  With Props
    ' Find beginning of code For Properties you need to differ between Let, Get and Set
    For i = .Body To .Top + .Lines
      If InStr(1, .Code.Lines(i, 1), .Type _
        + IIf(ProcKind = vbext_pk_Get, " Get", "") _
        + IIf(ProcKind = vbext_pk_Let, " Let", "") _
        + IIf(ProcKind = vbext_pk_Set, " Set", "") _
        + " " + Member.Name) > 0 Then
        While InStr(1, .Code.Lines(i, 1), "_") = Len(.Code.Lines(i, 1))
          i = i + 1
        Wend
        CodeFound = True
        Exit For
      End If
    Next i
    If CodeFound = False Then Exit Sub
    iStart = i
    While .Top + .Lines - .Body < 5
        .Code.InsertLines iStart + 1, "'"
        .Lines = .Lines + 1
    Wend
    ' Nach bereits vorhandenen ErrorHandlern suchen
    ' Ist ein anderer Error Handler vorhanden wird dieser beibehalten
    ' ein alter xxxErrHandler wird
berschrieben
    For i = iStart + 1 To .Top + .Lines - 2
      If InStr(1, .Code.Lines(i, 1), "Dim ") > 0 Then iCountDim = iCountDim + 1
      If InStr(1, .Code.Lines(i, 1), "On Error GoTo") > 0 Then
        If InStr(1, .Code.Lines(i, 1), "On Error GoTo 0") > 0 Then
          strTmp = .Code.Lines(i, 1)
          Replace strTmp, "On Error GoTo 0", "On Error Goto xxxErrHandler"
          .Code.DeleteLines i, 1
          .Code.InsertLines i, strTmp
        ElseIf InStr(1, .Code.Lines(i, 1), "On Error GoTo xxxErrHandler") > 0 Then
          OldErrHandlerFound = True
        Else
          ' If you don't select 'Erase other ErrHandlers' the sub will exit
          If mnuDelOthers.Checked Then
            If Not Left$(.Code.Lines(i, 1), 2) = "' " Then
              OtherErrHandler = .Code.Lines(i, 1)
              .Code.DeleteLines i, 1
              .Code.InsertLines i, "' " + OtherErrHandler
              OtherErrHandler = Right$(OtherErrHandler, Len(OtherErrHandler) _
               - (InStr(1, OtherErrHandler, "On Error") + 14))
            End If
          ElseIf i < iStart + 5 + iCountDim Then
            Exit Sub
          End If
        End If
      End If

    Next i
    ' Nach alten Status Infos suchen und diese l
schen
    i = iStart + 1
    Do
      If i > .Top + .Lines - 5 Then Exit Do
      While InStr(1, .Code.Lines(i, 1), "gstatus = """ & .ParentName & "." & Member.Name & " Line", vbTextCompare) > 0
        .Code.DeleteLines i, 1
        .Lines = .Lines - 1

      Wend
      ' Bei Exit h
rt der Spass auf
      If InStr(1, .Code.Lines(i, 1), "Exit " & .Type) = 1 Then Exit Do

      If (i - iStart) Mod 10 = 0 Then
        ' N
chsten Zeilenanfang suchen
        While Right(.Code.Lines(i - 1, 1), 1) = "_"
           i = i + 1
           If i > .Lines - 6 Then Exit Do
           If InStr(1, .Code.Lines(i, 1), "Exit " & .Type) = 1 Then Exit Do
        Wend
        ' Einr
ckung bestimmen
        Einrueck = Len(.Code.Lines(i - 1, 1)) - Len(LTrim(.Code.Lines(i - 1, 1)))
        ' Neues Status-Info einf
gen aber nur wenn Option gesetzt
        If Right(.Code.Lines(i - 1, 1), 1) <> "_" And mnuOptStatus.Checked Then
          .Code.InsertLines i, Space(Einrueck) + "gstatus = """ & .ParentName & "." & Member.Name & " Line " & i & """" & " ' Inserted by CodeCompleter"
          .Lines = .Lines + 1
          i = i + 1
        End If
      End If
      i = i + 1
    Loop
    ' Alte ErrHandler l
schen
    For i = iStart + 1 To .Top + .Lines
      If InStr(1, .Code.Lines(i, 1), "End " + .Type) > 0 Then
        CodeFound = True
        Exit For
      ElseIf InStr(1, .Code.Lines(i, 1), "xxxErrHandler:") > 0 Then
        DeleteOld = True
        .Code.DeleteLines i
        .Code.DeleteLines i - 1 ' Exit ...
        If .Code.Lines(i - 2, 1) = "GetObjectContext.SetComplete" Then
          .Code.DeleteLines i - 2
          .Lines = .Lines - 1
          i = i - 1
        End If
        .Lines = .Lines - 2
        i = i - 2
      ElseIf InStr(1, .Code.Lines(i, 1), OtherErrHandler + ":") > 0 Then
        DeleteOther = True
        OtherErrHandler = "' " + .Code.Lines(i, 1)
        .Code.DeleteLines i, 1
        .Code.InsertLines i, OtherErrHandler
      ElseIf DeleteOld Then
        .Code.DeleteLines i
        .Lines = .Lines - 1
        i = i - 1
      ElseIf DeleteOther Then
        OtherErrHandler = "' " + .Code.Lines(i, 1)
        .Code.DeleteLines i, 1
        .Code.InsertLines i, OtherErrHandler
      End If

    Next i
    If CodeFound = False Then MsgBox "InsertErrorCode: End not found!": Exit Sub
    ' Neuen ErrHandler einf
    If OldErrHandlerFound = False Then
      Call .Code.InsertLines(iStart + 1, "On Error Goto xxxErrHandler" + vbCrLf + _
        "gstatus = """ & .ParentName & "." & Member.Name & " Start""")
      .Lines = .Lines + 2
      i = i + 2
    End If
    ' Den ausgew
hlten ErrHandler einf
    If ErrType = errTMsgBox Then ' Message Box einf
gen (nur f
r Anwendungen!)
        strInsert = "Exit " & .Type & vbCrLf & "xxxErrHandler: " + vbCrLf _
        + "Dim xxxErrText as string" + vbCrLf _
        + "xxxErrText = ""Status: "" & gstatus & vbcrlf & ""Fehler in " & .ParentName & "." & Member.Name & """ & vbcrlf & Err.Description & vbcrlf & err.number & vbcrlf & err.Source" _
        If mnuOptResumeNextExit.Checked Then ' Message Box mit Resume Next Exit
          strInsert = strInsert + _
            vbCrLf + "Select Case msgBox " _
            + "(xxxErrText, vbCritical + vbAbortRetryIgnore, " _
            + """Fehler! in Programmversion "" & App.Major & ""."" & App.Minor & ""."" & App.Revision)" _
            + ": Case vbRetry: gstatus = ""xxxResume"" : Resume: " _
            + "Case vbIgnore: gstatus = ""xxxResumeNext"" : Resume Next: End Select "
        Else ' Message Box nur mit OK
          strInsert = strInsert + _
            vbCrLf + "call msgBox (xxxErrText, vbCritical , " _
            + """Fehler! in Programmversion "" & App.Major & ""."" & App.Minor & ""."" & App.Revision)"
        End If
        strInsert = strInsert + vbCrLf _
          + "Call LogError(Err.Number, Err.Description, Err.Source, gStatus, """ & .ParentName & "." & Member.Name & """)"
        .Code.InsertLines i, strInsert
    ElseIf ErrType = errTRaise Then ' Raise Error f
r normale ActiveX Komponenten
        ErrConstName = InsertNextErrorConstant(Member)
        .Code.InsertLines i, "Exit " & .Type & vbCrLf & "xxxErrHandler: " + vbCrLf _
        + "Dim xxxErrText as string" + vbCrLf _
        + "xxxErrText = ""Status: "" & gstatus & "" //Fehler in " & .ParentName & "." & Member.Name & """ & "": "" & err.number & "", "" & Err.Description & "", "" & err.Source" _
        + vbCrLf + "Call LogError(Err.Number, Err.Description, Err.Source, gStatus, """ & .ParentName & "." & Member.Name & """) " _
        + vbCrLf + "gstatus = ""xxxErrHandler in " & .ParentName & "." & Member.Name & """" _
        + vbCrLf + "Call RaiseError(" + ErrConstName + ", xxxErrText, App.ExeName & "": "" & App.Major & ""."" & App.Minor & ""."" & App.Revision) "
    ElseIf ErrType = errTRaiseWithSetAbort Then ' Raise Error f
r MTS-Komponenten
        ErrConstName = InsertNextErrorConstant(Member)
        If mnuOptSetComplete.Checked Then ' Set Complete einf
          strInsert = strInsert + "GetObjectContext.SetComplete" + vbCrLf
        End If
        strInsert = strInsert + "Exit " & .Type & vbCrLf & "xxxErrHandler: " + vbCrLf _
        + "Dim xxxErrText as string" + vbCrLf
        If mnuOptSetAbort Then ' Set Abort einf
          strInsert = strInsert + "GetObjectContext.SetAbort" + vbCrLf
        End If
        strInsert = strInsert + "xxxErrText = ""Status: "" & gstatus & "" //Fehler in " & .ParentName & "." & Member.Name & """ & "": "" & err.number & "", "" & Err.Description & "", "" & err.Source" _
        + vbCrLf + "Call LogError(Err.Number, Err.Description, Err.Source, gStatus, """ & .ParentName & "." & Member.Name & """) " _
        + vbCrLf + "gstatus = ""xxxErrHandler in " & .ParentName & "." & Member.Name & """" _
        + vbCrLf + "Call RaiseError(" + ErrConstName + ", xxxErrText, App.ExeName & "": "" & App.Major & ""."" & App.Minor & ""."" & App.Revision) "
        .Code.InsertLines i, strInsert
    End If
  End With
  Props.Lines = 0
  Props.Body = 0
  Props.Top = 0
  DeleteOld = False
  DeleteOther = False
  strInsert = ""
  CodeFound = False
  OtherErrHandler = ""
Loop Until Loops = 0
End Sub
Private Function getspaces(varString As String)
End Function